#!/usr/bin/perl
use warnings;
use strict;
use Socket;
use Encode;
use feature 'switch';

use Data::Dumper;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 0;
$Data::Dumper::Useqq = 1;
$| = 1;
my $VERBOSE = 0;
my $LLVMDebugVersion = 0x60000;

socket(LISTEN, PF_INET, SOCK_STREAM, getprotobyname('tcp'))
  || die "Failed to create socket: $!";
setsockopt(LISTEN, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
  || die "Failed to set socket option: $!";
bind(LISTEN, sockaddr_in(5678, inet_aton("localhost")))
  || die "Failed to bind socket: $!";
listen(LISTEN, SOMAXCONN)
  || die "Failed to listen on socket: $!";

my $PROMPT="(acdb) ";

print "Alchemy Debugger -- inspired by GDB\n";
print "Waiting for connection...\n$PROMPT";

my ($rtot, $wtot, $etot, $rnow, $wnow, $enow);

my $fnLISTEN = fileno(LISTEN);
my $fnSTDIN = fileno(STDIN);
my $fnMI;
my $mifrag;
my $userin;
my $micount = 0;
my $cmdId = 0;
my $selectedFrame = 0;
my @responses;
my %filemappings = ();
$rtot = $wtot = $etot = '';
vec($rtot, $fnSTDIN, 1) = 1;
vec($rtot, $fnLISTEN, 1) = 1;
# $etot = $rtot | $wtot;

sub frameSummary;
sub parseMI;
sub callMI;
sub withMIValue;
sub list;
sub lastline;

sub fromCString {
  $_ = shift;
  s/\\n/\n/;
  s/\\r/\r/;
  s/\\\"/\"/;
  s/\\\\/\\/;
  return $_;
}

my $lastcmd = "";
my $running = 1;
$SIG{INT} = sub {
  if (defined($fnMI)) {
    print MI "\x03";
  } else {
    $running = 0;
  }
};
while ($running) {
  if (-1 == select($rnow=$rtot, $wnow=$wtot, $enow=$etot, undef)) {
    print "$!\n";
    next;
  }
  if (defined($fnMI) && vec($rnow, $fnMI, 1)) {
    my ($read, $mimore);
    unless ($read = sysread MI, $mimore, 1024) {
      print "Connection closed.\n$PROMPT";
      close MI;
      vec($rtot, $fnMI, 1) = 0;
      undef $fnMI;
      $micount = 0;
      @responses = ();
      $cmdId = 0;
    } else {
      $mifrag .= $mimore;
      while ($read == 1024 && $mifrag !~ /\(gdb\) \n/s) {
        $read = sysread MI, $mimore, 1024;
        $mifrag .= $mimore;
      }
      my @mifrags = split(/\n(?=[\*\(\~]|[0-9]+\^)/, $mifrag, -1);
      $mifrag = pop @mifrags;
      my $leftover = "";
      for my $mi (@mifrags) {
        if ($VERBOSE) {
          my $vb = substr(Dumper($mi), 1, -1);
          if (length($vb) > 73) {
            $vb = substr($vb, 0, 60) . "..." . substr($vb, -10);
          }
          print ">> $vb\n";
        }
        $mi = "$leftover\n$mi" if $leftover;
        $leftover = "";
        chomp $mi;
        next unless $mi && $mi ne "(gdb) ";
        given ($mi) {
          when (/^[0-9]+\^[^,]+(?:,.*[\]\}"])?$/s) {
            $mi =~ /^([0-9]+)([^0-9].*)$/s;
            my ($class, $result) = split(',',$2,2);
            my $resp = $responses[$1];
            undef $responses[$1];
            if (defined($result)) {
              if ($result =~ /^value=\"/) {
                # optimization for huge value strings ($ds)
                $result = { value => fromCString(substr($result,7,-1)) };
              } else {
                $result = parseMI("{$result}");
              }
            }
            &$resp($class, $result)
              unless $class eq "^running";
          }
          when (/^[0-9]+\^/) {
            $leftover = $mi;
          }
          when (/^\*stopped$/) {
            $micount --;
            $selectedFrame = 0;
            frameSummary();
          }
          when (/^~"(.*)"$/s) {
            print fromCString($1);
          }
          when (/^~".*[^"]$/s) {
            $leftover = $mi;
          }
          default {
            if ($VERBOSE) {
              print "Unrecognised MI received.\n";
            } else {
              print ">>? " . Dumper($mi) . "\n";
            }
          }
        }
      }
      $mifrag = "$leftover\n$mifrag" if $leftover;
    }
  }
  if (vec($rnow, $fnLISTEN, 1)) {
    if (defined($fnMI)) {
      vec($rtot, $fnMI, 1) = 0;
      close(MI);
      print "New connection.  Old session discarded.\n";
    }
    accept MI, LISTEN;
    binmode MI;
    select(MI);
    $| = 1;
    select(STDOUT);
    $fnMI = fileno(MI);
    vec($rtot, $fnMI, 1) = 1;
    print "Connected.\n";
    frameSummary();
  }
  if (vec($rnow, $fnSTDIN, 1)) {
    sysread STDIN, $userin, 1024;
    chomp $userin;
    $userin = $lastcmd unless $userin;
    $lastcmd = $userin;
    my ($cmd, $args) = split(/\s+/, $userin, 2);
    given ($cmd) {
      when (/^bt|^w|^ba/) { # backtrace, where
        my $frameselector = "";
        my $selection;
        my $nextMachine;
        $selection = sub {
        my $after = shift;
        callMI "stack-list-frames $frameselector", sub {
          my %result = @_;
          my @frames = @{$result{stack}};
          my $frameout;
          $frameout = sub {
            my $frame = shift @frames;
            unless (defined $frame) {
              callMI "stack-select-frame $selectedFrame";
              $after->() if $after;
              return;
            }
            my %frame = %{$frame->{frame}};
            callMI "stack-select-frame ${frame{level}}", sub {
            withMIValue "\$state", sub {
              my $state = shift;
              print "#$frame{level}";
              print ($frame{level} == $selectedFrame ? "*" : " ");
              print " _state$state";
              unless (ref($frame{func})) {
                print " in $frame{func} ()";
              } else {
                $nextMachine =~ / FSM_(.*)\]/;
                print " in $1 ()";
              }
              unless (ref($frame{file})) {
                print " at $frame{file}:$frame{line}";
              } elsif ($frame{line} != 0) {
                print " at :$frame{line}"
              }
              print "\n";
              withMIValue "\$caller", sub {
                $nextMachine = shift;
                $frameout->();
              }
            };
            };
          };
          $frameout->();
        } };
        unless ($args) {
          withMIValue "\$gworker", sub {
            $nextMachine = shift;
            $selection->();
          }
        } else {
          callMI "stack-info-depth", sub {
            my %result = @_;
            my $depth = $result{depth};
            if ($args < 0) {
              $frameselector = $depth + $args;
              callMI "stack-select-frame " . ($frameselector - 1), sub {
                withMIValue "\$caller", sub {
                  $nextMachine = shift;
                  $selection->();
                }
              }
            } else {
              $frameselector = "0 " . ($args - 1);
              withMIValue "\$gworker", sub {
                $nextMachine = shift;
                $selection->(sub {
                  if ($args < $depth) {
                    print "(More stack frames follow...)\n";
                  }
                });
              }
            }
          }
        }
      }
      when (/^n/) { # next
        callMI "exec-next";
      }
      when (/^s/) { # step
        callMI "exec-step";
      }
      when (/^fi/) { # finish
        callMI "exec-finish";
      }
      when (/^c/) { # continue
        callMI "exec-continue";
      }
      when (/^f/) { # frame
        unless ($args) {
          frameSummary();
          break;
        }
        $selectedFrame = $args;
        print "#$selectedFrame* ";
        callMI "stack-select-frame $args", \&frameSummary
      }
      when (/^up/) { # up
        $args = 1 unless $args;
        callMI "stack-info-depth", sub {
          my %result = @_;
          my $depth = $result{depth};
          if ($selectedFrame >= $depth - 1) {
            print "Initial frame selected; you cannot go up.\n";
            return;
          }
          $selectedFrame += $args;
          if ($selectedFrame >= $depth) {
            $selectedFrame = $depth - 1;
          }
          print "#$selectedFrame* ";
          callMI "stack-select-frame $args", \&frameSummary
        }
      }
      when (/^do/) { # down
        $args = 1 unless $args;
        if ($selectedFrame <= 0) {
          print "Bottom (innermost) frame selected; you cannot go down.\n";
          print $PROMPT;
          break;
        }
        $selectedFrame -= $args;
        $selectedFrame = 0 if $selectedFrame < 0;
        print "#$selectedFrame* ";
        callMI "stack-select-frame $args", \&frameSummary
      }
      when (/^l/) { # list
        my $file = undef;
        $args = "" unless defined($args);
        if ($args =~ s/^(.*)://) {
          $file = $1;
        }
        given ($args) {
          when (/^\+?$/) { list "+0", undef, $file; }
          when ("-") { list undef, listhead(), $file; }
          when (/^,(.*)$/) { list undef, $1, $file; }
          when (/^(.*),$/) { list $1, undef, $file; }
          when (/^(.*),(.*)/) { list $1, $2, $file; }
          default { list $args, "c"; }
        }
        print $PROMPT;
      }
      when (/^p/) { # print
        withMIValue $args, sub {
          my $val = shift;
          print " = $val\n";
        }, sub {
          print "No symbol \"$args\" in current context.\n";
        }
      }
      when (/^q/) { # quit
        if (defined $fnMI) {
          callMI "exec-continue";
          callMI "gdb-exit";
        }
        $running = 0;
      }
      when (/^dump/) { # write memory to file
        print "Requesting contents of memory ...\n";
        withMIValue "\$ds", sub {
          unless (open DUMPFILE, ">$args") {
            print "Failed to open $args: $!\n";
            return;
          }
          my $ds = decode("utf8", shift);
          $ds = encode("iso-8859-1", $ds, sub {
            my ($val) = @_;
            return chr(($val >> 6) | 0xc0) .
                   chr(($val & 0x3f) | 0x80)
              if $val < 0x800;
            return chr(($val >> 12) | 0xe0) .
                   chr((($val >> 6) & 0x3f) | 0xc0) .
                   chr(($val & 0x3f) | 0x80)
              if $val < 0x10000;
            return chr(($val >> 18) | 0xf0) .
                   chr((($val >> 12) & 0x3f) | 0xe0) .
                   chr((($val >> 6) & 0x3f) | 0xc0) .
                   chr(($val & 0x3f) | 0x80);
          });
          binmode DUMPFILE;
          syswrite DUMPFILE, $ds;
          close DUMPFILE;
          print "Memory written to $args.\n";
        }
      }
      when (/^importdebug/) { # load debug information from process memory
        print "Requesting contents of memory...\n";
        withMIValue "\$ds", sub {
        
        }
      }
      default {
        print "Undefined command: \"$cmd\".\n$PROMPT";
      }
    }
  }
}

print "$!\ngoodbye!\n";

close(LISTEN) || die "Failed to close socket: $!";
exit;

sub splitMI {
  my $list = shift;
  my @ret = ();
  while ($list =~ /\G,?((?>""|".*?[^\\]")|\[\]|\[(?:(?1),?)*?\]|\{\}|\{(?:.*?=(?1),?)*?\}|.*?=(?1))/gs) {
    push @ret, $1;
  }
  return @ret;
}

sub parseMI {
  my $orig = shift;
  my $value = substr($orig, 1);
  chop($value);
  given (substr($orig, 0, 1)) {
    when ('"') { return fromCString($value); }
    when ('[') { 
      my @ret = ();
      foreach (splitMI($value)) { push @ret, parseMI($_); }
      return \@ret;
    }
    when ('{') {
      my %ret = ();
      foreach (splitMI($value)) { /^([^=]*?)=(.*)$/s; my $key = $1; $ret{$key} = parseMI($2); }
      return \%ret;
    }
    default {
      $orig =~ /^([^=]*?)=(.*)$/s;
      my $key = $1;
      return { $key => parseMI($2) };
    }
  }
}

sub frameSummary {
  my $machine;
  my $summaryFunc = sub {
    my %result = @_;
    my %frame = %{$result{stack}->[0]->{frame}};
    withMIValue "\$state", sub {
      my $state = shift;
      unless ($selectedFrame || ref($frame{func})) {
        print "${frame{func}} ()";
      } else {
        print "_state$state";
        unless (ref($frame{func})) {
          print " in ${frame{func}} ()";
        } else {
          $machine =~ / FSM_(.*)\]/;
          print " in $1 ()";
        }
      }
      unless (ref($frame{file})) {
        if (defined($filemappings{$frame{file}})) {
          $frame{file} = $filemappings{$frame{file}};
        }
        print " at $frame{file}:$frame{line}\n";
        unless ($frame{file} eq "***invalid filename***") {
          list $frame{line}, $frame{line}, $frame{file};
          centerlist();
        }
      } else {
        print " at :$frame{line}" unless $frame{line} == 0;
        print "\n";
      }
    }
  };
  unless ($selectedFrame) {
    withMIValue "\$gworker", sub {
      $machine = shift;	
      callMI "stack-list-frames $selectedFrame $selectedFrame", $summaryFunc;
    }
  } else {
    callMI "stack-select-frame " . ($selectedFrame - 1), sub {
      withMIValue "\$caller", sub {
        $machine = shift;
        callMI "stack-select-frame $selectedFrame", sub {
          callMI "stack-list-frames $selectedFrame $selectedFrame", $summaryFunc;
        }
      }
    }
  }
}

sub callMI {
  my $cmd = shift;
  my $callback = shift;
  my $errorhandler = shift;
  if (!defined $fnMI) {
    print "The program is not being run.\n$PROMPT";
    return;
  }
  $micount ++;
  print MI "$cmdId-$cmd\n";
  print "<< $cmdId-$cmd\n" if $VERBOSE;
  $responses[$cmdId] = sub {
    my $class = shift;
    my $result = shift;
    given ($class) {
      when ("^done") {
        $callback->(%$result) if defined($callback);
      }
      when ("^error") {
        if (defined($errorhandler)) {
          $errorhandler->(%$result);
        } else {
          print "ERROR: " . Dumper($result);
        }
      }
      default {
          print "$class " . Dumper($result);
      }
    }
    $micount --;
    if ($micount == 0) { print $PROMPT; }
  };
  $cmdId ++;
}

sub withMIValue {
  my ($varname, $callback, $handler) = @_;
  callMI "var-create - * $varname", sub {
    my %result = @_;
    my $vname = $result{name};
    callMI "var-evaluate-expression $vname", sub {
      my %result = @_;
      $callback->($result{value});
    };
    callMI "var-delete $vname";
  }, $handler;
}

my ($listfile, $listline, $listhead, $listtail);
sub listhead  {
  return $listhead;
}
my $numlines;
my $startoffset;
sub centerlist {
  $numlines = 10;
  $listtail -= $numlines / 2;
}
sub list {
  my ($line1, $line2, $file) = @_;
  $file = $listfile unless defined $file;
  if (!defined($listfile) || $listfile ne $file) {
    if (!defined $file) {
      print "No file is loaded.\n";
      return;
    }
    $listfile = undef;
    close LISTFILE;
    if (!open LISTFILE, "<$file") {
      print "  Failed to open: $!\n";
      my $opened = 0;
      if ($! eq "No such file or directory") {
	for (rindex($file,"/") + 1 .. length($file) - 1) {
          my $newfile = $file;
          substr($newfile, $_, 0) = "/";
          if (open LISTFILE, "<$newfile") {
            print "  Fudging into: $newfile\n";
            $filemappings{$file} = $newfile;
            $opened = 1;
            last;
          }
        }
      }
      return unless $opened;
    }
    $listfile = $file;
    $listline = 1;
    $listtail = 1;
  }
  if (defined($line1)) {
    given ($line1) {
      when (/^\+(.*)$/) { $line1 = $listtail + $1; }
      when (/^\-(.*)$/) { $line1 = $listtail - $1; }
    }
    given ($line2) {
      when (undef) { $line2 = $line1 + $numlines - 1; }
      when (/^\+(.*)$/) { $line2 = $line1 + $1; }
      when (/^\-(.*)$/) { $line2 = $line1 - $1; }
      when ("c") { 
        $line1 -= $numlines / 2;
        $line2 = $line1 + $numlines - 1;
      }
    }
  } else {
    given ($line2) {
      when (undef) { $line2 = $listtail + $numlines; }
      when (/^\+(.*)$/) { $line2 = $listtail + $1; }
      when (/^\-(.*)$/) { $line2 = $listtail - $1; }
    }
    $line2 --;
    $line1 = $line2 - $numlines + 1;
  }
  if ($line1 < $listline) {
    $listline = 1;
    seek LISTFILE, 0, 0;
  }
  while ($listline < $line1) {
    <LISTFILE>;
    $listline ++;
  }
  $listhead = $listline;
  while ($listline <= $line2) {
    $_ = <LISTFILE>; chomp;
    print "$listline\t$_\n";
    $listline ++;
  }
  $listtail = $listline;
}
